home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / env / start.scm < prev    next >
Text File  |  1995-10-13  |  2KB  |  68 lines
  1. ; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.
  2.  
  3.  
  4. (define (start structs-to-open)
  5.   (lambda (structs-thunk)
  6.     (usual-resumer
  7.      (lambda (arg)
  8.        (let* ((structs (structs-thunk))
  9.           (b (make-built-in-structures structs)))
  10.      (initialize-interaction-environment! b)
  11.      (with-interaction-environment
  12.          (make-initial-package b structs-to-open)
  13.        (lambda ()
  14.          (command-processor (cond ((assq 'usual-commands structs)
  15.                        => (lambda (z)
  16.                         (structure-package (cdr z))))
  17.                       (else #f))
  18.                 arg))))))))
  19.  
  20. ; The structs argument is an a-list of (name . structure), as computed
  21. ; by the expression returned by reify-structures.
  22.  
  23. (define (make-built-in-structures structs)
  24.   (let* ((p (make-simple-package '() #f #f 'built-in-structures))
  25.      (s (make-structure p
  26.           (lambda ()
  27.             (make-simple-interface
  28.                #f            ;name
  29.                (cons 'built-in-structures (map car structs))))
  30.           'built-in-structures)))
  31.     (for-each (lambda (name+struct)
  32.         (environment-define! p
  33.                      (car name+struct)
  34.                      (cdr name+struct)))
  35.           structs)
  36.     (environment-define! p 'built-in-structures s)
  37.     s))
  38.  
  39. (define (initialize-interaction-environment! built-in-structures)
  40.   (let ((scheme (*structure-ref built-in-structures 'scheme))
  41.     (tower (make-tower built-in-structures 'interaction)))
  42.     (set-interaction-environment!
  43.      (make-simple-package (list scheme) #t tower 'interaction))
  44.  
  45.     (set-scheme-report-environment!
  46.      5
  47.      (make-simple-package (list scheme) #t tower 'r5rs))))
  48.  
  49. ; Intended for bootstrapping the command processor.
  50.  
  51. (define (make-initial-package built-in-structures structs-to-open)
  52.   (let ((p (make-simple-package
  53.         (cons built-in-structures
  54.           (map (lambda (name)
  55.              (*structure-ref built-in-structures name))
  56.                structs-to-open))
  57.         eval
  58.         (make-tower built-in-structures 'initial)
  59.         'initial)))
  60.     (environment-define! p 'built-in-structures built-in-structures)
  61.     p))
  62.  
  63. (define (make-tower built-in-structures id)
  64.   (make-reflective-tower eval
  65.              (list (*structure-ref built-in-structures
  66.                            'scheme))
  67.              id))
  68.